home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / AddOns / eupvm.c < prev    next >
C/C++ Source or Header  |  1992-06-08  |  10KB  |  449 lines
  1. /*  
  2.   *
  3.   *  PVM/Feel interface
  4.   *          uses reader module...
  5.   */
  6.  
  7. /* PVM functions:
  8.  *   pvm_enroll(name)
  9.  *   pvm_initiate(hosttype, name)
  10.  *   pvm_leave()
  11.  *   pbm_self()
  12.  *   pvm_snd(id type message)
  13.  *   pvm_rcv(type) -> [object, info]
  14.  *   pvm_recvmulti(types) -> [object, info]
  15.  *   pvm_terminate()
  16.  *   status(pvm_id) -> bool
  17.  *   
  18.  */
  19.  
  20. #include <stdio.h>
  21. #include "defs.h"
  22. #include "structs.h"
  23. #include "funcalls.h"
  24. #include "global.h"
  25. #include "error.h"
  26. #include "allocate.h"
  27. #include "class.h"
  28. #include "modboot.h"
  29. #include "bootstrap.h"
  30. #include "allocate.h"
  31. #include "generics.h"
  32. #include "calls.h"
  33.  
  34. #include "obread.h"
  35. #include "eupvm_p.h"
  36.  
  37. /* Max message size */
  38. #define PVM_MSGBUF 16384
  39.  
  40. /* class, returned by enroll, used by snd */
  41.  
  42. #define PVM_NAME(id) (CAR(id))
  43. #define PVM_NUMBER(id) (CDR(id))
  44.  
  45. LispObject Pvm_Id;
  46.  
  47. static LispObject make_pvm_id(LispObject *stacktop,LispObject name,int n)
  48. {
  49.   LispObject new_id,xx;
  50.   
  51.   STACK_TMP(name);
  52.   xx=allocate_integer(stacktop,n);
  53.   UNSTACK_TMP(name);
  54.   new_id = EUCALL_2(Fn_cons,name,xx);
  55.   lval_classof(new_id) = Pvm_Id;
  56.   
  57.   return new_id;
  58. }
  59.  
  60. static EUFUN_1(Fn_make_pvm_id_from_pair, pair)
  61. {
  62.   LispObject new_ob;
  63.  
  64.   if (!is_cons(pair))
  65.     CallError(stacktop,"make-id: Type error",pair,NONCONTINUABLE);
  66.  
  67.   new_ob = EUCALL_2(Fn_cons,CAR(pair),CDR(pair));
  68.   lval_classof(new_ob) = Pvm_Id;
  69.   
  70.   return new_ob;
  71. }
  72. EUFUN_CLOSE
  73.  
  74. static EUFUN_1( Fn_make_pvm_id, name)
  75. {
  76.   return make_pvm_id(stacktop,name,-1);
  77. }
  78. EUFUN_CLOSE
  79.  
  80. static EUFUN_1( Fn_pvm_enroll, name)
  81. {
  82.   int ret;
  83.   
  84.   if (!is_string(name))
  85.     CallError(stacktop,"enroll: expected a string",name,NONCONTINUABLE);
  86.  
  87.   if ((ret = enroll(stringof(name))) < 0)
  88.     CallError(stacktop,"enroll: call failed",name,NONCONTINUABLE);
  89.  
  90.   return make_pvm_id(stacktop,name,ret);
  91. }
  92. EUFUN_CLOSE
  93.  
  94. /* Name is an executable in ~/pvm/<ARCH> */
  95. /* type is a machine type, () if any will do.. */
  96. static EUFUN_2( Fn_pvm_initiate_by_type, type, name)
  97. {
  98.   int ret;
  99.  
  100.   if(!is_string(type) || !is_string(name))
  101.     CallError(stacktop,"initiate: type error",name,NONCONTINUABLE);
  102.  
  103.   if ((ret = initiate(stringof(name),stringof(type))) < 0)
  104.     CallError(stacktop,"initiate: call failed",nil,NONCONTINUABLE);
  105.   
  106.   return make_pvm_id(stacktop,name,ret);
  107.  
  108. }
  109. EUFUN_CLOSE
  110.  
  111. static EUFUN_2( Fn_pvm_initiate_by_host_name, hostname, name)
  112. {
  113.   int ret;
  114.  
  115.   if(!is_string(hostname) || !is_string(name))
  116.     CallError(stacktop,"initiate: type error",hostname,NONCONTINUABLE);
  117.  
  118.   if ((ret = initiateM(stringof(name),stringof(hostname))) < 0)
  119.     CallError(stacktop,"initiate: call failed",nil,NONCONTINUABLE);
  120.   
  121.   return make_pvm_id(stacktop,name,ret);
  122.   
  123. }
  124. EUFUN_CLOSE
  125.  
  126. /* Note that this closes stdio buffers */
  127. static EUFUN_0( Fn_pvm_leave)
  128. {
  129.   leave();
  130.   
  131.   return nil;
  132. }
  133. EUFUN_CLOSE
  134.  
  135. static EUFUN_1( Fn_pvm_terminate, pvm_id)
  136. {
  137.   int ret;
  138.  
  139.   if (EUCALL_2(Fn_subclassp,classof(pvm_id),Pvm_Id)==nil)
  140.     CallError(stacktop,"terminate: type error",nil,NONCONTINUABLE);
  141.   
  142.   if ((ret = terminate(PVM_NAME(pvm_id),PVM_NUMBER(pvm_id))) < 0)
  143.     CallError(stacktop,"terminate: call failed",pvm_id,NONCONTINUABLE);
  144.  
  145.   return nil;
  146. }
  147. EUFUN_CLOSE
  148.  
  149. static EUFUN_1( Fn_pvm_status, pvm_id)
  150. {
  151.   int ret;
  152.  
  153.   if (EUCALL_2(Fn_subclassp,classof(pvm_id),Pvm_Id)==nil)
  154.     CallError(stacktop,"status: type error",nil,NONCONTINUABLE);
  155.   
  156.   if ((ret = status(PVM_NAME(pvm_id),PVM_NUMBER(pvm_id))) < 0)
  157.     CallError(stacktop,"status: call failed",pvm_id,NONCONTINUABLE);
  158.  
  159.   if (ret)
  160.     return lisptrue;
  161.   else
  162.     return nil;  
  163. }
  164. EUFUN_CLOSE
  165.  
  166. /* Message is any sendable object */
  167.  
  168.  
  169. static EUFUN_4( Fn_pvm_snd, id, msg_type, msg, reader_maybe)
  170. {
  171.   LispObject xx;
  172. #ifdef CGC
  173.   unsigned char buf[PVM_MSGBUF];
  174. #else
  175.   unsigned char *buf=NULL;
  176. #endif
  177.  
  178.   unsigned char *ptr;
  179.   int len;
  180.  
  181. #ifndef CGC
  182.   buf = (unsigned char *)feel_malloc(PVM_MSGBUF);
  183. #endif
  184.   
  185.   ptr = buf;
  186.   write_obj(stacktop,msg,&ptr,reader_maybe);
  187.   len = ptr - buf;
  188.   EUBUG(fprintf(stderr,"Send: %d bytes sent\n",len));
  189.   msg_type=ARG_1(stackbase);
  190.   if (!is_fixnum(msg_type))
  191.     CallError(stacktop,"send: Type error",msg_type,NONCONTINUABLE);
  192.  
  193.   id=ARG_0(stackbase);
  194.   initsend();  
  195.   putnint(&len,1);
  196.   putbytes(buf,len);
  197.   if (snd(stringof(PVM_NAME(id)),intval(PVM_NUMBER(id)),
  198.       intval(msg_type))<0)
  199.     CallError(stacktop,"send: call failed",id,NONCONTINUABLE);
  200. #ifndef CGC
  201.   feel_free(buf);
  202. #endif
  203.  
  204.   return nil;
  205. }
  206. EUFUN_CLOSE
  207.  
  208. static EUFUN_3( Fn_pvm_rcv, msg_type, info_p, reader_maybe)
  209. {
  210.   static LispObject read_msg(LispObject *, LispObject , LispObject );  
  211.   
  212.   if (!is_fixnum(msg_type))
  213.     CallError(stacktop,"rcv: type error",msg_type,NONCONTINUABLE);
  214.  
  215.   if (rcv(intval(msg_type)) < 0)
  216.     CallError(stacktop,"rcv: call failed",nil,NONCONTINUABLE);
  217.   
  218.   return (read_msg(stacktop,info_p, reader_maybe));
  219. }
  220. EUFUN_CLOSE
  221.  
  222. EUFUN_3( Fn_pvm_rcvmulti, typelist, info_p,  reader_maybe)
  223. {
  224.   static LispObject read_msg(LispObject *,LispObject , LispObject );
  225.   LispObject ptr;
  226.   int len;
  227.  
  228.   len = 0;
  229.   ptr = typelist;
  230.  
  231.   while(is_cons(ptr))
  232.     {    
  233.       len++;
  234.       ptr = CDR(ptr);
  235.     }
  236.  
  237.   {    
  238.     int buf[len];
  239.     int i=0;
  240.  
  241.     ptr=typelist;
  242.     while(is_cons(ptr))
  243.       {
  244.     buf[i]=intval(CAR(ptr));
  245.     i++;
  246.     ptr=CDR(ptr);
  247.       }
  248.     
  249.     if (rcvmulti(len,buf)<0)
  250.       CallError(stacktop,"rcvmulti: Call failed",nil,NONCONTINUABLE);
  251.   }
  252.   return(read_msg(stacktop,info_p, reader_maybe));
  253. }
  254. EUFUN_CLOSE
  255.  
  256. static LispObject read_msg(LispObject *stacktop,LispObject info_p,LispObject reader_maybe)
  257. {
  258. #ifdef CGC
  259.   unsigned char buf[PVM_MSGBUF];
  260. #else
  261.   unsigned char *buf=NULL;
  262. #endif
  263.   char nam_buf[128];
  264.   unsigned char *ptr;
  265.   LispObject new_obj;
  266.  
  267.   LispObject sender,result;
  268.   int len,inum,type;
  269.  
  270.   if (getnint(&len,1) < 0)
  271.     CallError(stacktop,"rcv: getnint call failed",nil,NONCONTINUABLE);
  272.   
  273.   EUBUG(fprintf(stderr,"Rcv: Got %d bytes\n",len));
  274. #ifndef CGC
  275.   buf =  (unsigned char *)feel_malloc(PVM_MSGBUF);
  276. #endif
  277.  
  278.   ptr = buf;
  279.   if (getbytes(buf,len) < 0)
  280.     CallError(stacktop,"rcv: getbytes call failed",nil,NONCONTINUABLE);
  281.   
  282.   STACK_TMP(info_p);
  283.   new_obj = read_obj(stacktop,&ptr,reader_maybe);
  284.   UNSTACK_TMP(info_p);
  285. #ifndef CGC
  286.   feel_free(buf);
  287. #endif
  288.   EUBUG(fprintf(stderr,"Recv: used %d bytes\n",ptr-buf));
  289.   if (info_p!=nil)
  290.     {
  291.       LispObject xx;
  292.       STACK_TMP(new_obj);
  293.       rcvinfo(&len,&type,&nam_buf[0],&inum);    
  294.       xx=allocate_integer(stacktop,type);
  295.       xx=EUCALL_2(Fn_cons,xx,nil);
  296.       STACK_TMP(xx);
  297.       xx=allocate_string(stacktop,nam_buf,strlen(nam_buf));
  298.       sender = make_pvm_id(stacktop,xx,inum);
  299.       UNSTACK_TMP(xx);
  300.       xx=EUCALL_2(Fn_cons,sender,xx);
  301.       UNSTACK_TMP(new_obj);
  302.       result=EUCALL_2(Fn_cons,new_obj,xx);
  303.       return result;
  304.     }
  305.   else
  306.     {
  307.       return new_obj;
  308.     }
  309. }
  310.  
  311.  
  312. /* Readable-p */
  313. static EUFUN_1( Fn_pvm_probe, type)
  314. {
  315.   int ret;
  316.  
  317.   if(!is_fixnum(type))
  318.     CallError(stacktop,"probe: type error",type,NONCONTINUABLE);
  319.  
  320.   if((ret = probe(intval(type))) < 0)
  321.     return nil;
  322.   else 
  323.     return allocate_integer(stacktop,ret);
  324. }
  325. EUFUN_CLOSE
  326.  
  327. static EUFUN_1( Fn_pvm_probe_multi, typelist)
  328. {
  329.   LispObject ptr;
  330.   int len,ret;
  331.  
  332.   len = 0;
  333.   ptr = typelist;
  334.  
  335.   while(is_cons(ptr))
  336.     {    
  337.       len++;
  338.       ptr = CDR(ptr);
  339.     }
  340.  
  341.   {    
  342.     int buf[len];
  343.     int i=0;
  344.  
  345.     ptr=typelist;
  346.     while(is_cons(ptr))
  347.       {
  348.     buf[i]=intval(CAR(ptr));
  349.     i++;
  350.     ptr=CDR(ptr);
  351.       }
  352.     ret=0;
  353.     /*probemulti(len,buf); --- not yet written*/
  354.   }
  355.   return nil;
  356. }
  357. EUFUN_CLOSE
  358.  
  359. static EUFUN_2( Fn_pvm_barrier, name, number)
  360. {
  361.   if (!is_string(name))
  362.     CallError(stacktop,"barrier: type error",name,NONCONTINUABLE);
  363.   
  364.   if (!is_fixnum(number))
  365.     CallError(stacktop,"barrier: type error",number,NONCONTINUABLE);
  366.  
  367.   if (barrier(stringof(name),intval(number))<0)
  368.     CallError(stacktop,"barrier: call error",number,NONCONTINUABLE);
  369.  
  370.   return nil;
  371.  
  372. }
  373. EUFUN_CLOSE
  374.  
  375. static EUFUN_1( Fn_pvm_ready, name) /* simple semaphore */
  376. {
  377.   if (!is_string(name))
  378.     CallError(stacktop," reader: type error",name,NONCONTINUABLE);
  379.  
  380.   if (ready(stringof(name))<0)
  381.     CallError(stacktop," reader: call error",name,NONCONTINUABLE);
  382.  
  383.   return nil;
  384. }
  385. EUFUN_CLOSE
  386.  
  387. static EUFUN_1( Fn_pvm_waituntil, name)
  388. {
  389.   if (!is_string(name))
  390.     CallError(stacktop," waituntil: type error",name,NONCONTINUABLE);
  391.  
  392.   if (waituntil(stringof(name))<0)
  393.     CallError(stacktop,"waituntil: call error",name,NONCONTINUABLE);
  394.  
  395.   return nil;
  396. }
  397. EUFUN_CLOSE
  398.  
  399. static EUFUN_0( Fn_pvm_whoami)
  400. {
  401.   int ret;
  402.   char buf[128];
  403.   LispObject xx;
  404.  
  405.   if(whoami(buf,&ret)<0)
  406.     CallError(stacktop,"whoami: call error",nil,NONCONTINUABLE);
  407.  
  408.   xx=allocate_string(stacktop,buf,(int) strlen(buf));
  409.   return make_pvm_id(stacktop,xx,ret);
  410. }
  411. EUFUN_CLOSE
  412.  
  413. #define PVM_MODULE_ENTRIES (18)
  414. MODULE Module_pvm;
  415. LispObject Module_pvm_values[PVM_MODULE_ENTRIES];
  416.  
  417. void INIT_pvm(LispObject *stacktop)
  418. {
  419.   extern LispObject Standard_Class,Object, Primitive_Class;
  420.  
  421.   Pvm_Id = allocate_class(stacktop,NULL);
  422.   add_root(&Pvm_Id);
  423.   make_class(stacktop,Pvm_Id,"pvm-id",Primitive_Class,Object,0);
  424.  
  425.   open_module(stacktop,&Module_pvm,Module_pvm_values,"pvm",
  426.           PVM_MODULE_ENTRIES);
  427.   (void) make_module_function(stacktop,"make-pvm-id",Fn_make_pvm_id,1);
  428.   (void) make_module_function(stacktop,"pvm-status",Fn_pvm_status,1);
  429.   (void) make_module_function(stacktop,"pvm-leave",Fn_pvm_leave,0);
  430.   (void) make_module_function(stacktop,"pvm-send",Fn_pvm_snd,-4);
  431.   (void) make_module_function(stacktop,"pvm-recv",Fn_pvm_rcv,-3);
  432.   (void) make_module_function(stacktop,"pvm-recv-multi",Fn_pvm_rcvmulti,-3);
  433.   (void) make_module_function(stacktop,"pvm-initiate-by-type",Fn_pvm_initiate_by_type,2);
  434.   (void) make_module_function(stacktop,"pvm-initiate-by-hostname",Fn_pvm_initiate_by_host_name,2);
  435.   (void) make_module_function(stacktop,"pvm-enroll",Fn_pvm_enroll,1);
  436.   (void) make_module_function(stacktop,"pvm-probe",Fn_pvm_probe,1);
  437.   (void) make_module_function(stacktop,"pvm-probe-multi",Fn_pvm_probe_multi,1);
  438.   (void) make_module_function(stacktop,"pvm-barrier",Fn_pvm_barrier,2);
  439.   (void) make_module_function(stacktop,"pvm-ready",Fn_pvm_ready,1);
  440.   (void) make_module_function(stacktop,"pvm-waituntil",Fn_pvm_waituntil,2);
  441.   (void) make_module_function(stacktop,"pvm-terminate",Fn_pvm_terminate,2);
  442.   (void) make_module_function(stacktop,"pvm-whoami",Fn_pvm_whoami,0);
  443.   (void) make_module_function(stacktop,"pvm-make-id-from-pair",
  444.                   Fn_make_pvm_id_from_pair,1);
  445.   (void) make_module_entry(stacktop,"pvm-id",Pvm_Id);
  446.   close_module();
  447.  
  448. }              
  449.